(define-imported-class picture i-rich-writeable)
(define-imported-class sprite picture)
(define-imported-class (image-class-kluge "IRichWriteable") object)
(define-imported-object pi "Math.PI" float)
(import (ceiling "Math.Ceiling" (proc (float) float))
	(object->integer "System.Convert.ToInt32" (proc (object) integer))
	(object->single-float "System.Convert.ToSingle"
			      (proc (object) single-float))
	(object->point-f "PointFVectorSpace.ToPointF"
			 (proc (object string)
			       (type-expression-value 'point-f)))
	(noise "PerlinNoise.Noise" (proc (object) single-float))
	(turbulence "PerlinNoise.Turbulence"
		    (proc (object single-float single-float integer)
			  single-float)))
(%import-object 'default-listener "Meta.TopLevel.rawOut"
		(type-expression-value 'i-rich-writeable))

(define-initialized-module (basic2d basic2-d)
  ;;;
  ;;; THE PICTURE CLASS
  ;;;

  (define-class picture image-class-kluge
    ;; COMPUTING BOUNDING BOXEN
    ;; This is hairy because we have to handle rotations
    (define cached-bounding-box (private rectangle-f) null)
    (define bbox-cached? (private boolean) #f)
    (define (bounding-box o) (public virtual property rectangle-f)
      (if (bbox-cached? o)
	  (cached-bounding-box o)
	  (let ((x-interval (measure o (point-f (cast single-float 1.0)
						(cast single-float 0.0))))
		(y-interval (measure o (point-f (cast single-float 0.0)
						(cast single-float 1.0)))))
	    (let ((bbox (new rectangle-f
			     (interval-min x-interval)
			     (interval-min y-interval)
			     (interval-size x-interval)
			     (interval-size y-interval))))
	      (set (cached-bounding-box o) bbox)
	      (set (bbox-cached? o) #t)
	      bbox))))

    ;; Project the object onto the axis give by the unit vector DIRECTION.
    (define (measure o (point-f direction)) (public virtual interval)
      (interval (cast float 0.0)
		(cast float 0.0)))

    ;; RENDERING, etc.
    (define (render o (graphics g) (pen p) (brush b)) (public virtual void)
      ;; Can't compile empty bodies and I don't want to fix it right now.
      (set g g))

    (define (to-bitmap o (color background)) (public bitmap)
      (let ((bbox (bounding-box o)))
	(let ((b (make-bitmap (+ (cast integer
				       (max 1
					    (ceiling (rectangle-width bbox))))
				 1)
			      (+ (cast integer
				       (max 1
					    (ceiling (rectangle-height bbox))))
				 1))))
	  (let ((g (graphics-from-image b)))
	    (clear g background)
	    (translate-transform g
				 (- (rectangle-left bbox))
				 (- (rectangle-top bbox)))
	    (render o g
		    (pen (color-from-name "Black") 1)
		    null)
	    (dispose g)
	    b))))

    (define (rich-write o w)
      (let ((g (create-graphics w)))
	(let ((b (to-metafile o g)))
	  (write w b)
	  (dispose g)
	  (dispose b))))

;; This seems to correctly make a metafile, but the clipboard won't recognize
;; it as a metafile, only "System.Drawing.Imaging.Metafile"...
    (define (to-metafile o (graphics listener-g)) (public image)
      ;; Sick, but I need a graphics object...
      (set (smoothing-mode listener-g)
	   render-antialiased)
      (let ((stream (memory-stream)))
	(let ((hdc (get-hdc listener-g)))
	  (let ((m (new metafile
			stream
			hdc)))
	    (let ((g (graphics-from-image m)))
	      (set (smoothing-mode g)
		   render-antialiased)
	      (render o g
		      (pen (color-from-name "Black") 1)
		      null)
	      (dispose g)
	      (release-hdc listener-g hdc)
	      m)))))
    
    (define (thunk? o) (public static boolean)
      (is? o procedure))

    )

  (define-primitive-procedure (bounding-box (picture picture))
    "Returns the smallest rectangle that contains the entire picture"
    (bounding-box picture))

  ;;;;
  ;;;; COMPOUND PICTURES
  ;;;;

  (define-class group-base picture
    (define pictures (public (array picture)) null)

    (define (measure g dir)
      (let ((components (pictures g)))
	(cond ((= (length components) 0)
	       (interval (cast float 0.0)
			 (cast float 0.0)))
	      (else
	       (let ((range (measure (vector-ref components 0)
				     dir)))
		 (for ((i 1 (+ i 1)))
		      (< i (length components))
		      (union range
			     (measure (vector-ref components i)
				      dir)))
		 range)))))

    (define (render gr g p b)
      (do-array (o (pictures gr))
		(render o g p b))))

  (define-class (group pictures) group-base)

  (define-primitive-procedure (group . component-pictures)
    "A picture consisting of all the component-pictures overlaid on one another."
    (let ((obs (new-array picture (length component-pictures))))
      (copy-into component-pictures obs 0)
      (new group obs)))

  ;;;
  ;;; PAINTED AND INKED GROUPS
  ;;;

  (define-class (painted-group m-brush pictures) group-base
    (define m-brush "m_brush" (private object) null)
    (define (new-brush this) "Brush"  (public property brush)
      (let ((b (m-brush this)))
	(cond ((is? b brush)
	       (cast brush b))
	      (else
	       (set b (call0 (cast procedure b)))
	       (cond ((eq? b null)
		      null)
		     ((is? b brush)
		      (cast brush b))
		     ((is? b color)
		      (solid-brush (cast color b)))
		     ((is? b string)
		      (solid-brush (color-from-name (cast string b))))
		     ((is? b symbol)
		      (solid-brush (color-from-name (pname (cast symbol b)))))
		     (else
		      (throw (argument-type-exception "brush"
						      b
						      (type->clr-type brush)))))))))

    (define (render gr g p b)
      (render base g p (new-brush gr))))

  (define-primitive-procedure (paint . brush-and-pictures)
    "Groups pictures and fills them with the specified brush."
    (arglist color/brush pictures ...)
    (let ((obs (new-array picture (- (length brush-and-pictures) 1)))
	  (arg1 (vector-ref brush-and-pictures 0)))
      (copy-subarray brush-and-pictures 1 obs 0 (length obs))
      (let ((br (begin 0
		       (cond ((eq? arg1 null)
			      null)
			     ((or (is? arg1 brush)
				  (thunk? arg1))
			      arg1)
			     ((is? arg1 color)
			      (solid-brush (cast color arg1)))
			     ((is? arg1 string)
			      (solid-brush (color-from-name (cast string arg1))))
			     ((is? arg1 symbol)
			      (solid-brush (color-from-name (pname (cast symbol arg1)))))
			     (else
			      (throw (exception "First argument must be a brush, color, or color name")))))))
	(painted-group br obs))))

  (define-class (inked-group m-pen pictures) group-base
    (define m-pen "m_pen" (private object) null)
    (define (new-pen this) "Pen" (public property pen)
      (let ((p (m-pen this)))
	(cond ((null? p)
	       null)
	      ((is? p pen)
	       (cast pen p))
	      (else
	       (set p (call0 (cast procedure p)))
	       (cond ((eq? p null)
		      null)
		     ((is? p pen)
		      (cast pen p))
		     ((is? p color)
		      (pen (cast color p) 1))
		     ((is? p string)
		      (pen (color-from-name (cast string p)) 1))
		     ((is? p symbol)
		      (pen (color-from-name (pname (cast symbol p))) 1))
		     (else
		      (throw (exception "First argument must be a pen, color, or color name"))))))))

    (define (render gr g p b)
      (render base g (new-pen gr) b)))

  (define-primitive-procedure (ink . pen-and-pictures)
    "Group pictures and inks their outlines with the specified pen."
    (arglist color/pen pictures ...)
    (let ((obs (new-array picture (- (length pen-and-pictures) 1)))
	  (arg1 (vector-ref pen-and-pictures 0)))
      (copy-subarray pen-and-pictures 1 obs 0 (length obs))
      (let ((p (begin 0
		      (cond ((eq? arg1 null)
			     null)
			    ((or (is? arg1 pen)
				 (thunk? arg1))
			      arg1)
			    ((is? arg1 color)
			     (pen (cast color arg1) 1))
			    ((is? arg1 string)
			     (pen (color-from-name (cast string arg1)) 1))
			    ((is? arg1 symbol)
			     (pen (color-from-name (pname (cast symbol arg1))) 1))
			    (else
			     (throw (exception "First argument must be a pen, color, or color name")))))))
	(inked-group p obs))))

  ;;;;
  ;;;; TRANSFORMS
  ;;;;

  ;;;
  ;;; TRANSLATION
  ;;;

  (define-class (translated-group translation proc pictures) group-base
    (define translation (public point-f) null)
    (define proc "procedure" (public procedure) null)

    (define (measure t dir)
      (let ((i (measure base dir))
	    (dot (project (translation t) dir)))
	(new interval
	     (+ (interval-min i)
		dot)
	     (+ (interval-max i)
		dot))))

    (define (render t g p b)
      (let ((saved (begin-container g)))
	(let ((pt (if (null? (proc t))
		     (translation t)
		     (object->point-f (traced-call0-no-stack (proc t))
				      "translate"))))
	  (translate-transform g 
			       (point-f-x pt)
			       (point-f-y pt))
	  (render base g p b)
	  (end-container g saved)))))

  (define-primitive-procedure (translate . point-and-pictures)
    "Groups pictures and translates them so the origin is at the specified point."
    (arglist point pictures ...)
    (let ((obs (new-array picture (- (length point-and-pictures) 1)))
	  (point-arg (vector-ref point-and-pictures 0)))
      (copy-subarray point-and-pictures 1 obs 0 (length obs))
      (if (is? point-arg procedure)
	  (translated-group (point-f 0 0)
			    (cast procedure point-arg)
			    obs)
	  (translated-group (object->point-f point-arg
					     "translate")
			    null
			    obs))))

  (define-class (rotated-group angle pictures) group-base
    (define angle (public single-float) null)

    (define (measure t dir)
      (let ((a (* 2 (/ pi 360.0)
		  (angle t))))
	(let ((cosco (cast single-float (cast float (cos a))))
	      (sinco (cast single-float (cast float (sin a)))))
	  (measure base
		   (point-f (+ (* cosco
				  (point-f-x dir))
			       (* sinco
				  (point-f-y dir)))
			    (- (* cosco
				  (point-f-y dir))
			       (* sinco
				  (point-f-x dir))))))))

    (define (render t g p b)
      (let ((saved (begin-container g)))
	(rotate-transform g 
			  (angle t))
	(render base g p b)
	(end-container g saved))))

  (define-primitive-procedure (rotate . angle-and-pictures)
    "Groups pictures and rotates them clockwise angle degress about the origin."
    (arglist angle pictures ...)
    (let ((obs (new-array picture (- (length angle-and-pictures) 1))))
      (copy-subarray angle-and-pictures 1 obs 0 (length obs))
      (rotated-group (cast single-float
			  (vector-ref angle-and-pictures 0))
		    obs)))

  (define-class (scaled-group x-scale y-scale pictures) group-base
    (define x-scale (public single-float) 0)
    (define y-scale (public single-float) 0)

    (define (measure s dir)
      (let ((i (measure base dir))
	    (scale-factor (project dir
				   (point-f (x-scale s)
					    (y-scale s)))))
	(interval (* (interval-min i)
		     scale-factor)
		  (* (interval-max i)
		     scale-factor))))

    (define (render s g p b)
      (when (and (not (= (x-scale s) 0.0))
		   (not (= (y-scale s) 0.0)))
	(let ((saved (begin-container g)))
	  (scale-transform g (x-scale s) (y-scale s))
	  (render base g p b)
	  (end-container g saved)))))

  (define-primitive-procedure (scale . scale-and-pictures)
    "Groups pictures and grows or shrinks them about the origin."
    (arglist scale-factor pictures ...)
    (let ((obs (new-array picture (- (length scale-and-pictures) 1))))
      (copy-subarray scale-and-pictures 1 obs 0 (length obs))
      (let ((scale-factor (vector-ref scale-and-pictures 0)))
	(cond ((is? scale-factor point)
	       (let ((scale-factor-point (cast point scale-factor)))
		 (scaled-group (cast single-float
				     (point-x scale-factor-point))
			       (cast single-float
				     (point-y scale-factor-point))
			       obs)))
	      ((is? scale-factor point-f)
	       (let ((scale-factor-point-f (cast point-f scale-factor)))
		 (scaled-group (point-f-x scale-factor-point-f)
			       (point-f-y scale-factor-point-f)
			       obs)))
	      (else
	       (let ((scale-factor-scalar (object->single-float scale-factor)))
		 (scaled-group scale-factor-scalar
			       scale-factor-scalar
			       obs)))))))

  (define-class (sprite pic update-thunk
			position orientation)
    picture
    (define pic "picture" (public picture) null)
    (define position (public point-f) (point-f 0 0))
    (define velocity (public point-f) (point-f 0 0))
    (define orientation (public single-float) (cast single-float 0.0))
    (define angular-velocity (public single-float) (cast single-float 0.0))
    (define new-position (public point-f) (point-f 0 0))
    (define new-velocity (public point-f) (point-f 0 0))
    (define new-orientation (public single-float) (cast single-float 0.0))
    (define new-angular-velocity (public single-float) (cast single-float 0.0))

    (define update-thunk (public procedure) null)

    (define (update s (single-float delta)) (public virtual void)
      (unless (null? (update-thunk s))
	(traced-call2-no-stack (update-thunk s)
			       s
			       delta)))

    (define (render s g p b)
      (set (position s)
	   (new-position s))
      (set (velocity s)
	   (new-velocity s))
      (set (orientation s)
	   (new-orientation s))
      (set (angular-velocity s)
	   (new-angular-velocity s))
      (let ((saved (begin-container g)))
	(translate-transform g
			     (point-f-x (position s))
			     (point-f-y (position s)))
	(rotate-transform g
			  (* (orientation s)
			     (/ -360 (* 2 3.141592))))
	(render (pic s)
		g p b)
	(end-container g saved))))

;  (define-class (velocity-controller linear-controller angular-controller) call-interface-procedure
;    (define linear-controller (public procedure) null)
;    (define angular-controller (public procedure) null)
;    (define (call2 c s-obj delta-obj)
;      (let ((s (cast sprite s-obj))
;	    (delta (cast single-float delta-obj)))
;	;; Run the user code to get new velocities
;	(set (new-velocity s)
;	     (object->point-f (traced-call1-no-stack (linear-controller c) s)
;			      "Velocity update"))
;	(set (new-angular-velocity s)
;	     (object->single-float (traced-call1-no-stack (angular-controller c) s)))
;	;; Update position
;	(set (new-position s)
;	     (point-f (+ (point-f-x (position s))
;			 (* (point-f-x (new-velocity s))
;			    delta))
;		      (+ (point-f-y (position s))
;			 (* (point-f-y (new-velocity s))
;			    delta))))
;	(set (new-orientation s)
;	     (+ (orientation s)
;		(* (new-angular-velocity s)
;		   delta))))))

;  (define-class (force-controller mass linear-controller moi angular-controller) call-interface-procedure
;    (define mass (public single-float) 1)
;    (define moi (public single-float) 1)
;    (define linear-controller (public procedure) null)
;    (define angular-controller (public procedure) null)
;    (define (call2 c s-obj delta-obj)
;      (let ((s (cast sprite s-obj))
;	    (delta (cast single-float delta-obj)))
;	;; Run the user code to get new velocities
;	(set (new-velocity s)
;	     (let ((force (object->point-f (traced-call1-no-stack (linear-controller c) s)
;					   "Velocity update"))
;		   (k (/ delta
;			 (mass c))))
;	       (point-f (+ (point-f-x (velocity s))
;			   (* k
;			      (point-f-x force)))
;			(+ (point-f-y (velocity s))
;			   (* k
;			      (point-f-y force))))))
;	(set (new-angular-velocity s)
;	     (* delta
;		(/ (object->single-float (traced-call1-no-stack (angular-controller c) s))
;		   (moi c))))
;	;; Update position
;	(set (new-position s)
;	     (point-f (+ (point-f-x (position s))
;			 (* (point-f-x (new-velocity s))
;			    delta))
;		      (+ (point-f-y (position s))
;			 (* (point-f-y (new-velocity s))
;			    delta))))
;	(set (new-orientation s)
;	     (+ (orientation s)
;		(* (new-angular-velocity s)
;		   delta))))))

;  (define-class (sprite update-proc pictures) group-base
;    (define update-proc (public procedure) null)
;    (define (render s g p b)
;      (let ((saved (begin-container g))
;	    (new-position (cast point-f
;				(apply (update-proc s)
;				       (new-array object 1 0)))))
;	(translate-transform g
;			     (point-f-x new-position)
;			     (point-f-x new-position))
;	(render base g p b)
;	(end-container g saved))))

  ;;;;
  ;;;; PRIMITIVE PICTURES
  ;;;;

  ;;;
  ;;; LINES
  ;;;

  (define-class (line start end) picture
    (define start (public point-f) null)
    (define end (public point-f) null)

    (define (measure l dir)
      (let ((i (projection-interval (start l) dir)))
	(extend-projection i
			   (end l)
			   dir)
	i))

    (define (render o g p b)
      (draw-line g p (start o) (end o))))

  (define-primitive-procedure (line start end)
    "A picture consisting of a single line."
    (new line
	 (object->point-f start "start")
	 (object->point-f end "end")))

  ;;;
  ;;; BOXES
  ;;;

  (define-class (box rect) picture
    (define rect "rectangle" (public rectangle) null)

    (define (measure bx dir)
      (let ((r (rect bx)))
	(let ((i (projection-interval (point-f (rectangle-left r)
					       (rectangle-top r))
				      dir)))
	  (extend-projection i
			     (point-f (rectangle-right r)
				      (rectangle-top r))
			     dir)
	  (extend-projection i
			     (point-f (rectangle-right r)
				      (rectangle-bottom r))
			     dir)
	
	  (extend-projection i
			     (point-f (rectangle-left r)
				      (rectangle-bottom r))
			     dir)
	  i)))

    (define (rectangle-from-spec corner1 corner2) (public static rectangle)
      (cond ((is? corner1 point-f)
	     (cond ((is? corner2 point-f)
		    (let ((c1 (cast point-f corner1))
			  (c2 (cast point-f corner2)))
		      (rectangle (cast integer (min (point-f-x c1)
						    (point-f-x c2)))
				 (cast integer (min (point-f-y c1)
						    (point-f-y c2)))
				 (cast integer (abs (- (point-f-x c1)
						       (point-f-x c2))))
				 (cast integer (abs (- (point-f-y c1)
						       (point-f-y c2)))))))
		   ((is? corner2 point)
		    (let ((c1 (cast point-f corner1))
			  (c2 (cast point corner2)))
		      (rectangle (cast integer (min (point-f-x c1)
						    (point-x c2)))
				 (cast integer (min (point-f-y c1)
						    (point-y c2)))
				 (cast integer (abs (- (point-f-x c1)
						       (point-x c2))))
				 (cast integer (abs (- (point-f-y c1)
						       (point-y c2)))))))
		   (else
		    (throw (exception "Arguments must be points or width and height")))))
	    ((is? corner1 point)
	     (cond ((is? corner2 point-f)
		    (let ((c1 (cast point corner1))
			  (c2 (cast point-f corner2)))
		      (rectangle (cast integer (min (point-x c1)
						    (point-f-x c2)))
				 (cast integer (min (point-y c1)
						    (point-f-y c2)))
				 (cast integer (abs (- (point-x c1)
						       (point-f-x c2))))
				 (cast integer (abs (- (point-y c1)
						       (point-f-y c2)))))))
		   ((is? corner2 point)
		    (let ((c1 (cast point corner1))
			  (c2 (cast point corner2)))
		      (rectangle (cast integer (min (point-x c1)
						    (point-x c2)))
				 (cast integer (min (point-y c1)
						    (point-y c2)))
				 (cast integer (abs (- (point-x c1)
						       (point-x c2))))
				 (cast integer (abs (- (point-y c1)
						       (point-y c2)))))))
		   (else
		    (throw (exception "Arguments must be points or width and height")))))
	    ((and (number? corner1)
		  (number? corner2))
	     (let ((width (to-int32 corner1))
		   (height (to-int32 corner2)))
	       (rectangle (- (/ width 2))
			  (- (/ height 2))
			  width
			  height)))
	    (else
	     (throw (exception "Arguments must be points or width and height")))))

    (define (rectangle-f-from-spec corner1 corner2) (public static rectangle-f)
      (cond ((is? corner1 point-f)
	     (cond ((is? corner2 point-f)
		    (let ((c1 (cast point-f corner1))
			  (c2 (cast point-f corner2)))
		      (rectangle-f (cast integer (min (point-f-x c1)
						      (point-f-x c2)))
				   (cast integer (min (point-f-y c1)
						      (point-f-y c2)))
				   (cast integer (abs (- (point-f-x c1)
							 (point-f-x c2))))
				   (cast integer (abs (- (point-f-y c1)
							 (point-f-y c2)))))))
		   ((is? corner2 point)
		    (let ((c1 (cast point-f corner1))
			  (c2 (cast point corner2)))
		      (rectangle-f (cast integer (min (point-f-x c1)
						      (point-x c2)))
				   (cast integer (min (point-f-y c1)
						      (point-y c2)))
				   (cast integer (abs (- (point-f-x c1)
							 (point-x c2))))
				   (cast integer (abs (- (point-f-y c1)
							 (point-y c2)))))))
		   (else
		    (throw (exception "Arguments must be points or width and height")))))
	    ((is? corner1 point)
	     (cond ((is? corner2 point-f)
		    (let ((c1 (cast point corner1))
			  (c2 (cast point-f corner2)))
		      (rectangle-f (cast integer (min (point-x c1)
						      (point-f-x c2)))
				   (cast integer (min (point-y c1)
						      (point-f-y c2)))
				   (cast integer (abs (- (point-x c1)
							 (point-f-x c2))))
				   (cast integer (abs (- (point-y c1)
							 (point-f-y c2)))))))
		   ((is? corner2 point)
		    (let ((c1 (cast point corner1))
			  (c2 (cast point corner2)))
		      (rectangle-f (cast integer (min (point-x c1)
						      (point-x c2)))
				   (cast integer (min (point-y c1)
						      (point-y c2)))
				   (cast integer (abs (- (point-x c1)
							 (point-x c2))))
				   (cast integer (abs (- (point-y c1)
							 (point-y c2)))))))
		   (else
		    (throw (exception "Arguments must be points or width and height")))))
	    ((and (number? corner1)
		  (number? corner2))
	     (let ((width (to-single corner1))
		   (height (to-single corner2)))
		      (rectangle-f (* -0.5 width)
				   (* -0.5 height)
				   width
				   height)))
	    (else
	     (throw (exception "Arguments must be points or width and height")))))

    (define (render bx g p b)
      (unless (eq? b null)
	(fill-rectangle g b (rect bx)))
      (unless (eq? p null)
	(draw-rectangle g p (rect bx)))))

  (define-primitive-procedure (box width/corner1 height/corner2)
    "Makes a picture consisting of a single box."
    (box (rectangle-from-spec width/corner1 height/corner2)))


  ;;;
  ;;; ELLIPSES
  ;;;

  (define-class (ellipse bounding-rect) picture
    (define bounding-rect "rectangle" (public rectangle-f) null)

    (define (measure e dir)
      (let ((r (bounding-rect e)))
	(let ((i (projection-interval (point-f (rectangle-left r)
					       (rectangle-top r))
				      dir)))
	  (extend-projection i
			     (point-f (rectangle-right r)
				      (rectangle-top r))
			     dir)
	  (extend-projection i
			     (point-f (rectangle-right r)
				      (rectangle-bottom r))
			     dir)
	
	  (extend-projection i
			     (point-f (rectangle-left r)
				      (rectangle-bottom r))
			     dir)
	  i)))

    (define (render e g p b)
      (unless (eq? b null)
	(fill-ellipse g b (bounding-rect e)))
      (unless (eq? p null)
	(draw-ellipse g p (bounding-rect e)))))

  (define-primitive-procedure (ellipse width/corner1 height/corner2)
    "Returns a picture consisting of a single ellipse"
    (ellipse (rectangle-f-from-spec width/corner1 height/corner2)))

  (define-class (image-picture im bounding-rect) picture
    (define im "image" (public image) null)
    (define bounding-rect "rectangle" (public rectangle-f) null)

    (define (measure e dir)
      (let ((r (bounding-rect e)))
	(let ((i (projection-interval (point-f (rectangle-left r)
					       (rectangle-top r))
				      dir)))
	  (extend-projection i
			     (point-f (rectangle-right r)
				      (rectangle-top r))
			     dir)
	  (extend-projection i
			     (point-f (rectangle-right r)
				      (rectangle-bottom r))
			     dir)
	
	  (extend-projection i
			     (point-f (rectangle-left r)
				      (rectangle-bottom r))
			     dir)
	  i)))

    (define (render i g p b)
      (draw-image g
		  (im i)
		  (bounding-rect i))))

  (define-primitive-procedure (image (object bitmap-or-filename))
    "Returns the specified image file as a picture"
    (let ((b (if (is? bitmap-or-filename
		      bitmap)
		 (cast bitmap bitmap-or-filename)
		 (bitmap (cast string bitmap-or-filename)))))
      (image-picture b
		     (rectangle-f 0 0
				  (size-width (size b))
				  (size-height (size b))))))


  (import (noise (object point))
	  "Returns a random number that varies with point")

  (define-class (clipped-group crect pictures) group-base
    (define crect "rectangle" (public rectangle-f) null)

    (define (measure bx dir)
      (let ((r (crect bx)))
	(let ((i (projection-interval (point-f (rectangle-left r)
					       (rectangle-top r))
				      dir)))
	  (extend-projection i
			     (point-f (rectangle-right r)
				      (rectangle-top r))
			     dir)
	  (extend-projection i
			     (point-f (rectangle-right r)
				      (rectangle-bottom r))
			     dir)
	
	  (extend-projection i
			     (point-f (rectangle-left r)
				      (rectangle-bottom r))
			     dir)
	  i)))

    (define (render cg g p b)
      (let ((saved (begin-container g)))
	(set (clip g)
	     (region (crect cg)))
	(render base g p b)
	(end-container g saved))))

  (define-primitive-procedure (clip . args)
    "Groups pictures clips them to the specified rectangle"
    (arglist width/corner1 height/corner2 pictures ...)
    (when (< (length args) 2)
      (throw (argument-count-exception args
				       (arglist-kluge (cast i-arglist this)))))
    (let ((obs (new-array picture (- (length args) 2)))
	  (width/corner1 (vector-ref args 0))
	  (height/corner2 (vector-ref args 1)))
      (copy-subarray args 2 obs 0 (length obs))
      (clipped-group (rectangle-f-from-spec width/corner1 height/corner2)
		     obs)))

  (define-primitive-w/methods (turbulence point/number alpha beta iterations)
    call-interface-procedure
    "The Perlin turbulence function"
    (define (call1 this point/number)
      (turbulence point/number 2 2 4))
    (define (call4 this point/number alpha beta iterations)
      (check-arg-type "alpha" alpha float)
      (check-arg-type "beta" beta float)
      (check-arg-type "iterations" iterations integer)
      (turbulence point/number
		  (to-single alpha)
		  (to-single beta)
		  (to-int32 iterations))))

  (define-primitive-procedure (width image/picture/rectangle)
    "Returns the width of the specified object in pixels."
    (cond ((is? image/picture/rectangle image)
	   (image-width (cast image image/picture/rectangle)))
	  ((is? image/picture/rectangle rectangle)
	   (rectangle-width (cast rectangle image/picture/rectangle)))
	  ((is? image/picture/rectangle rectangle-f)
	   (rectangle-width (cast rectangle-f image/picture/rectangle)))
	  ((is? image/picture/rectangle picture)
	   (rectangle-width (bounding-box (cast picture image/picture/rectangle))))
	  (else
	   (throw! (argument-exception "Argument must be an image, picture, or rectangle")
		   null null)
	   null)))

  (define-primitive-procedure (left-edge picture/rectangle)
    "Returns the X coordinate of the left edge of the specified object in pixels."
    (cond ((is? picture/rectangle rectangle)
	   (rectangle-left (cast rectangle picture/rectangle)))
	  ((is? picture/rectangle rectangle-f)
	   (rectangle-left (cast rectangle-f picture/rectangle)))
	  ((is? picture/rectangle picture)
	   (rectangle-left (bounding-box (cast picture picture/rectangle))))
	  (else
	   (throw! (argument-exception "Argument must be an picture, or rectangle")
		   null null)
	   null)))

  (define-primitive-procedure (right-edge picture/rectangle)
    "Returns the X coordinate of the right edge of the specified object in pixels."
    (cond ((is? picture/rectangle rectangle)
	   (rectangle-right (cast rectangle picture/rectangle)))
	  ((is? picture/rectangle rectangle-f)
	   (rectangle-right (cast rectangle-f picture/rectangle)))
	  ((is? picture/rectangle picture)
	   (rectangle-right (bounding-box (cast picture picture/rectangle))))
	  (else
	   (throw! (argument-exception "Argument must be an picture, or rectangle")
		   null null)
	   null)))

  (define-primitive-procedure (height image/picture/rectangle)
    "Returns the width of the specified object in pixels."
    (cond ((is? image/picture/rectangle image)
	   (image-height (cast image image/picture/rectangle)))
	  ((is? image/picture/rectangle rectangle)
	   (rectangle-height (cast rectangle image/picture/rectangle)))
	  ((is? image/picture/rectangle rectangle-f)
	   (rectangle-height (cast rectangle-f image/picture/rectangle)))
	  ((is? image/picture/rectangle picture)
	   (rectangle-height (bounding-box (cast picture image/picture/rectangle))))
	  (else
	   (throw! (argument-exception "Argument must be an image, picture, or rectangle")
		   null null)
	   null)))

  (define-primitive-procedure (top-edge picture/rectangle)
    "Returns the Y coordinate of the top of the specified object in pixels."
    (cond ((is? picture/rectangle rectangle)
	   (rectangle-top (cast rectangle picture/rectangle)))
	  ((is? picture/rectangle rectangle-f)
	   (rectangle-top (cast rectangle-f picture/rectangle)))
	  ((is? picture/rectangle picture)
	   (rectangle-top (bounding-box (cast picture picture/rectangle))))
	  (else
	   (throw! (argument-exception "Argument must be an picture, or rectangle")
		   null null)
	   null)))

  (define-primitive-procedure (bottom-edge picture/rectangle)
    "Returns the Y coodinate of the bottom of the specified object in pixels."
    (cond ((is? picture/rectangle rectangle)
	   (rectangle-bottom (cast rectangle picture/rectangle)))
	  ((is? picture/rectangle rectangle-f)
	   (rectangle-bottom (cast rectangle-f picture/rectangle)))
	  ((is? picture/rectangle picture)
	   (rectangle-bottom (bounding-box (cast picture picture/rectangle))))
	  (else
	   (throw! (argument-exception "Argument must be an picture, or rectangle")
		   null null)
	   null)))

  (define-primitive-procedure (center (picture pict))
    "The center point of the bounding box of picture"
    (let ((bbox (bounding-box pict)))
      (point-f (/ (+ (rectangle-right bbox)
		     (rectangle-left bbox))
		  2)
	       (/ (+ (rectangle-top bbox)
		     (rectangle-bottom bbox))
		  2))))

;  (define-primitive-procedure (color . name-or-components)
;    "Returns the color with the specified name, RGB values, or RGBA values."
;    (let ((nargs (length name-or-components)))
;      (unless (or (= nargs 1)
;		  (= nargs 3)
;		  (= nargs 4))
;	(throw
;	 (exception "Arguments to color must be a color name, rgb values, or argb values.")))
;      (cond ((= nargs 1)
;	     (let ((n (vector-ref name-or-components 0)))
;	       (cond ((is? n string)
;		      (color-from-name (cast string n)))
;		     ((is? n symbol)
;		      (color-from-name (pname (cast symbol n))))
;		     (else
;		      (throw (exception "Color name is not a string or symbol"))))))
;	    ((= nargs 3)
;	     (color-from-argb 255
;			      (object->integer (vector-ref name-or-components 0))
;			      (object->integer (vector-ref name-or-components 1))
;			      (object->integer (vector-ref name-or-components 2))))
;	    (else
;	     (color-from-argb (object->integer (vector-ref name-or-components 3))
;			      (object->integer (vector-ref name-or-components 0))
;			      (object->integer (vector-ref name-or-components 1))
;			      (object->integer (vector-ref name-or-components 2)))))))



  ;;;
  ;;; COMPUTED IMAGES
  ;;;

  (define-class (bad-pixel-value-exception value coordinates myproc)
    exception
    ("[Serializable]")
    (define value (public object) null)
    (define coordinates (public point) null)
    (define myproc "procedure" (public procedure) null))

  (define-primitive-procedure (bitmap-from-procedure (procedure proc)
						     (integer width)
						     (integer height))
    "Creates a bitmap whose pixels are computed by PROC"
    (let ((b (make-bitmap width height))
	  (non-point-function? (= (length (arglist-kluge (cast i-arglist proc)))
				  2))
	  (estack current-thread-eval-stack))
      (for ((i 0 (+ i 1)))
	   (< i width)
	 (for ((j 0 (+ j 1)))
	      (< j height)
	      (let ((pixel (if non-point-function?
			       (traced-call2 proc estack i j)
			       (traced-call1 proc estack (point i j)))))
		(cond ((is? pixel color)
		       (set-pixel b i j
				  (cast color
					pixel)))
		      ((number? pixel)
		       (let ((intensity (max 0
					     (min 255
						  (object->integer pixel)))))
			 (set-pixel b i j
				    (color-from-argb 255
						     intensity
						     intensity
						     intensity))))
		      (else
		       (throw (bad-pixel-value-exception pixel
							 (point i j)
							 proc)))))))
      b))

  (define-primitive-w/methods (map-bitmap procedure image ...)
    call-interface-procedure
    "Creates a new bitmap by passing the pixels of IMAGE(s) through PROCEDURE"
    (define (call2 this p i1)
      (let ((proc (checked-arg-cast "procedure" p procedure))
	    (im1 (checked-arg-cast "image" i1 bitmap)))
	(let ((width (image-width im1))
	      (height (image-height im1)))
	  (let ((b (make-bitmap width height)))
	    (for ((i 0 (+ i 1)))
		 (< i width)
		 (for ((j 0 (+ j 1)))
		      (< j height)
		      (set-pixel b i j
				 (cast color
				       (traced-call1-no-stack proc
						     (get-pixel im1 i j))))))
	    b))))
    (define (call3 this p i1 i2)
      (let ((proc (checked-arg-cast "procedure" p procedure))
	    (im1 (checked-arg-cast "image" i1 bitmap))
	    (im2 (checked-arg-cast "image" i2 bitmap)))
	(let ((width (image-width im1))
	      (height (image-height im1)))
	  (let ((b (make-bitmap width height)))
	    (for ((i 0 (+ i 1)))
		 (< i width)
		 (for ((j 0 (+ j 1)))
		      (< j height)
		      (set-pixel b i j
				 (cast color
				       (traced-call2-no-stack proc
						     (get-pixel im1 i j)
						     (get-pixel im2 i j))))))
	    b))))
    (define (call4 this p i1 i2 i3)
      (let ((proc (checked-arg-cast "procedure" p procedure))
	    (im1 (checked-arg-cast "image" i1 bitmap))
	    (im2 (checked-arg-cast "image" i2 bitmap))
	    (im3 (checked-arg-cast "image" i3 bitmap)))
	(let ((width (image-width im1))
	      (height (image-height im1)))
	  (let ((b (make-bitmap width height)))
	    (for ((i 0 (+ i 1)))
		 (< i width)
		 (for ((j 0 (+ j 1)))
		      (< j height)
		      (set-pixel b i j
				 (cast color
				       (traced-call3-no-stack proc
						     (get-pixel im1 i j)
						     (get-pixel im2 i j)
						     (get-pixel im3 i j))))))
	    b))))
    (define (call5 this p i1 i2 i3 i4)
      (let ((proc (checked-arg-cast "procedure" p procedure))
	    (im1 (checked-arg-cast "image" i1 bitmap))
	    (im2 (checked-arg-cast "image" i2 bitmap))
	    (im3 (checked-arg-cast "image" i3 bitmap))
	    (im4 (checked-arg-cast "image" i4 bitmap)))
	(let ((width (image-width im1))
	      (height (image-height im1)))
	  (let ((b (make-bitmap width height)))
	    (for ((i 0 (+ i 1)))
		 (< i width)
		 (for ((j 0 (+ j 1)))
		      (< j height)
		      (set-pixel b i j
				 (cast color
				       (traced-call4-no-stack proc
						     (get-pixel im1 i j)
						     (get-pixel im2 i j)
						     (get-pixel im3 i j)
						     (get-pixel im4 i j))))))
	    b)))))

  )